;;; idrop-display-methods.el --- Drop-down menu interface: display methods
;;; TODO: insert file and package descripion, history, commentary and license.

()

;;; x) user-customizable variables

(idrop-defcustom idrop-display-method 'overlays ;; (if window-system 'frame 'overlays)
  "Method to use to display the idrop"
  :type '(choice (const :tag "Frame" frame)
                 (const :tag "Overlays" overlays))
  :group 'idrop
  :set #'(lambda (symbol value)
           (cond ((eq value 'frame)
                  (setq idrop-display-method-fn 'idrop-display-frame)
                  (setq idrop-after-init-hook '(idrop-overlays-setup-control-overlay))
                  (setq idrop-cleanup-hook '(idrop-display-hide-frame))
                  (setq idrop-display-restretch-hook 'nil))
                 ((eq value 'overlays)
                  (setq idrop-display-method-fn         'idrop-display-overlays
                        idrop-after-init-hook           '(idrop-overlays-setup-control-overlay
                                                          idrop-overlays-after-init)
                        idrop-display-restretch-hook    '(idrop-overlays-delete)
                        idrop-cleanup-hook                 '(idrop-overlays-delete
                                                          idrop-overlays-after-exit)))
                 (t
                  nil))
           (set-default symbol value)))

;;; x) `frame' display method

(defvar idrop-frame nil
  "Emacs frame containing the idrop")

(defun idrop-display-exterminate-frame ()
  (interactive)
  (when idrop-frame
    (delete-frame idrop-frame))
  (setq idrop-frame nil))

(defun idrop-display-hide-frame ()
  (if  (and idrop-frame
            (frame-live-p idrop-frame))
      (make-frame-invisible idrop-frame)
    (idrop-display-exterminate-frame)))

(defun idrop-display-frame (dd user-input format)
  "Displays the idrop DD in a frame, creating, resizing, focusing
or just redrawing, if necessary to adjust the formatted lines
passed in list FORMAT."
  (unless (and idrop-frame
               (frame-live-p idrop-frame))
    (setq idrop-frame (idrop-display-create-frame dd))
    (set-window-buffer (frame-selected-window idrop-frame) (get-buffer-create "*idrop shit*")))
  (unless (frame-visible-p idrop-frame)
    (make-frame-visible idrop-frame))
  (set-frame-width     idrop-frame (idrop-width dd))
  (set-frame-height    idrop-frame (length (car format)))
  (save-excursion
    (save-window-excursion
      (raise-frame idrop-frame)
      (set-buffer (get-buffer-create "*idrop shit*"))
      (erase-buffer)
      (insert user-input)
      (dolist (f (car format))
        (insert f)
        ;; (insert "\n")
        )
      (setq mode-line-format nil)))
  ;; (select-frame-set-input-focus idrop-frame)
  )

(defun idrop-display-create-frame (dd)
  (make-frame `((name . "idrop")
              (width . 50)
              (height . 10)
              (minibuffer . nil)
              (fringe . nil)
              (user-position . t)        ; Emacs only
              (vertical-scroll-bars . nil) ; Emacs only
              (scrollbar-width . 0)        ; XEmacs only
              (scrollbar-height . 0)       ; XEmacs only
              (menu-bar-lines . 0)         ; Emacs only
              (tool-bar-lines . 0)         ; Emacs 21+ only
              (left-fringe    . 0)
              (right-fringe   . 0)
              (auto-lower . nil)
              (auto-raise . nil)
              (visibility . nil)
              ;; make initial frame small to avoid distraction
              )))

;;; x) `overlays' display method

(defvar idrop-overlays nil
  "Array containing quad lists of idrop overlays and strings.

The lists (OV BEFORE-STRING AFTER-STRING) containing a carefully
calculated overlay (in `idrop-overlays-do-display' and the
optional before and after strings that make it display correctly,
for as long as the idrop remains un-retretched and
un-refiletered.")

(defvar idrop-overlays-saved-truncate-lines nil
  "Used to save the value of `truncate-lines'.")

(defvar idrop-overlays-saved-modified-state 'idrop-unknown
  "Used to save the return value of `buffer-modified-p'.

In `idrop-overlays-after-init' this is set to `idrop-unknown' and
only set to some other value if an insertion is actually done.

In `idrop-overlays-after-exit' the original `buffer-modified-p'
is restored accordingly. ")

(defun idrop-overlays-after-init ()
  "Actions to take before any idrop overlays are displayed.

Saves value of some important variables, and a correctly sized
  `idrop-overlays' vector, if no suitable one exists."
  (setq idrop-overlays-saved-truncate-lines truncate-lines)
  (setq idrop-overlays-saved-modified-state 'idrop-unknown)
  (setq truncate-lines t)
  (unless (and idrop-overlays
               (eq (length idrop-overlays) (window-height)))
    (setq idrop-overlays (make-vector (window-height) nil))))

(defun idrop-overlays-after-exit ()
  "Actions to take after the idrop has been undisplayed and exited."
  (setq truncate-lines
        idrop-overlays-saved-truncate-lines)
  (setq idrop-overlays nil))

(defun idrop-overlays-setup-control-overlay ()
  "Instantiate `idrop-control-overlay' covering the whole buffer.

Associate its `local-map' property with `idrop-control-keymap'"
  (when idrop-control-overlay (delete-overlay idrop-control-overlay))
  (setf idrop-control-overlay (make-overlay (point-min) (point-max)))
  (overlay-put idrop-control-overlay  'local-map 'idrop-control-keymap))

(defun idrop-display-overlays (dd user-input format)
  "Displays the idrop DD according to formatted lines FORMAT.

USER-INPUT is a propertized and formatted string containing the
current input by the user.

FORMAT is a cons cell (LINES . OFFSET) where LINES is a list of
properly propertized and formatted strings that compose the idrop
list, and OFFSET is the index of the currently selected candidate
in that list, if any."
  ;; TODO: Support non-truncated lines
  ;; TODO: Add animation when nothing better to do, which really isn't now.
  (let* ((formatted-lines (first format))
         (height (if user-input
                     (1+ (length formatted-lines))
                   (length formatted-lines)))
         (offset (if (and user-input (second format))
                     (1+ (second format))
                   (second format)))
         (position-list (idrop-overlays-move-to-start (idrop-width dd)
                                                      height
                                                      offset))
         (column (first position-list))
         (screen-line (min (second position-list) (1- (window-height))))
         (missed-lines (cddr position-list)))
    ;;
    ;; After using `screen-line' to try to move to the correct
    ;; screen line, its basically just a key value to use in the
    ;; overlays arrays.
    ;;
    (when (> missed-lines 0)
      ;;
      ;; save very important `buffer-modified-p' value
      ;;
      (setq idrop-overlays-saved-modified-state (if (buffer-modified-p)
                                                    'idrop-modified
                                                  'idrop-not-modified))
      (let ((inhibit-modification-hooks t)
            (buffer-undo-list t)
            (buffer-read-only nil))
        (save-excursion
          (goto-char (point-max))
          (insert (make-string missed-lines 10)))
        (when idrop-control-overlay
          (move-overlay idrop-control-overlay (point-min) (point-max)))
        (put 'idrop-overlays 'idrop-missed-lines missed-lines)
        (move-to-window-line screen-line)))
    ;;
    ;; Delete useless overlays from `screen-line' down.
    ;;
    (idrop-overlays-delete-some-overlays (1+ screen-line) (1- (length idrop-overlays)))
    ;;
    ;; Display
    ;;
    (when user-input (push user-input formatted-lines))
    (dolist (f (nreverse formatted-lines))
      (idrop-overlays-do-display column f screen-line)
      (forward-line -1)
      (setq screen-line (max 0 (1- screen-line))))
    ;;
    ;; Delete useless overlays from 0 to `screen-line;
    ;;
    (idrop-overlays-delete-some-overlays 0 (1+ screen-line))))

(defun idrop-overlays-delete-some-overlays (start end)
  (idrop-mapv-range #'(lambda (quad)
                        (when quad
                          (delete-overlay (first quad))))
    idrop-overlays
    start
    end))

(defun idrop-overlays-calculate-available-space (dd)
  ;; TODO: later a hook function that helps adjust DD's width and
  ;; nvisible depending if the buffer can handle it should return a cons (XMAX . YMAX)


  )

(defun idrop-overlays-move-to-start (width height offset)
  "Calculates and moves to screen line where stacking the
overlays should start.

Returns a list (COLUMN SCREEN-LINE . MISSED-LINES) where:

* COLUMN is the calculated start column.

* SCREEN-LINE is the calculated screen line where stacking the
  overlays should start and where ideally point has been moved
  to.

* MISSED-LINES is the number of blank buffer lines that the move
  command missed."
  (let* ((column (let ((current-column (mod (current-column) (window-width)))
                       (window-width (window-width)))
                   (cond (;; if the idrop fits to the right, starting
                          ;; from current column, return
                          ;; `current-column'
                          (and (not (eq idrop--display-center-p 'center))
                               (<= (+ current-column width) window-width))
                          current-column)
                         (;; if the idrop fits in the window at all, center it horizontally
                          (>= window-width width)
                          (/ (- window-width width) 2))
                         (;; as a last resort use the first column
                          t
                          0))))
         (current-line (- (line-number-at-pos)
                                   (save-excursion
                                     (move-to-window-line 0)
                                     (line-number-at-pos))))
         (screen-line (+ (1- height)
                         (cond ((eq idrop--display-center-p 'wobble)
                                (- current-line offset))
                               ((eq idrop--display-center-p 'center)
                                (/ (- (window-height) height) 2))
                               ((eq idrop--display-center-p 'up)
                                (- height))
                               (t
                                current-line))))
         (missed-lines (- screen-line (move-to-window-line screen-line))))
    (cons column (cons screen-line missed-lines ))))

(defun idrop-overlays-do-display (start-column replacement &optional screen-line)
  "Overlays the string REPLACEMENT cleanly over existing text,
starting at START-COLUMN.

SCREEN-LINE might point, in `idrop-overlays', to a preformatted
already created overlay that this function reuses.

This function makes no assumptions abount the vertical placement
of the line inserted."
  (let* (string
         (ov-quad (when screen-line (aref idrop-overlays screen-line))))
    (cond ((and ov-quad
                (overlay-buffer (first ov-quad)))
           ;; If found and suitable (`overlay-buffer' checks for
           ;; existance) just change it a bit...
           (setq string (concat (second ov-quad)
                                replacement
                                (third ov-quad)))
           (overlay-put (first ov-quad) 'after-string string))
          (t
           (setq ov-quad (idrop-overlays-calculate-quad start-column replacement))
           (aset idrop-overlays screen-line ov-quad)))))

(defun idrop-overlays-calculate-quad (start-column replacement)
  "Actually does the complicated work for `idrop-overlays-do-display'.

See that functions description"
  (let (before-string
        after-string
        beg-point
        end-point
        (end-column (+ start-column (string-width replacement)))
        end-offset)
    ;;
    ;; Overlaying over existing fixed-witdh text.
    ;;
    ;; 1. Calculate `beg-point' and `before-string';
    ;;
    ;; Goto, try to go, to the the last column in the active
    ;; line.
    ;;
    (goto-char (point-at-eol))
    (cond ((< (current-column) start-column)
           ;;
           ;; We ended up before the desired start column,
           ;; whitespace `before-string' has to be inserted
           ;;
           (setq before-string (make-string (- start-column (current-column)) 32))
           (setq beg-point (point)))
          (t
           ;;
           ;; We're correct or we overshot, no whitespace
           ;; `before-string' necessary *unless* a tab happens
           ;; just before the start column. Thus, move to
           ;; `point-at-bol' then to `start-column', set
           ;; `beg-point' there and leave `before-string' nil.
           ;;
           (goto-char (point-at-bol))
           (move-to-column start-column)
           (setq beg-point (point))
           (when (> (current-column) start-column)
             ;;
             ;; ... *but* if we miraculously overshot it, we
             ;; know a tab was there. Go back through the tab,
             ;; make a small whitespace `before-string' with the
             ;; overshot difference.
             ;;
             (goto-char (1- (point)))
             (setq beg-point (point))
             (setq before-string (make-string (- start-column (current-column)) 32)))))
    ;;
    ;; 2. Calculate `end-point' and
    ;; `after-string'. `after-string' happens rarely in the
    ;; case of tabs.
    ;;
    ;; Try to go to `end-column',, set `end-point' there
    ;; calculate any overshoot (`end-offset'). If that is 0 or
    ;; we actually undershot, we're OK. But if we overshot we
    ;; have a tab again and have to make a whitespace
    ;; `after-string.
    ;;
    (move-to-column end-column)
    (setq end-point (point))
    (setq end-offset (- (current-column) end-column))
    (when (> end-offset 0) (setq after-string (make-string end-offset 32)))

    ;;
    ;; OK, now do easy stuff. Create, prepare the overlay quad
    ;; (overlay, `before-string', `end-string'), return it so it will
    ;; be stored in the `idrop-overlays' cache.
    ;;
    (setq string (concat before-string
                         replacement
                         after-string))
    (list (idrop-overlays-make-overlay beg-point end-point
                                       'invisible t
                                       'after-string string)
          before-string
          after-string
          nil)))

(defun idrop-overlays-delete ()
  "Delete all overlays registered in the `idrop-overlays' array.

Ensure `idrop-overlays' is left as an empty array, `window-height' tall."
  (interactive)
  (when idrop-overlays
    (idrop-mapv #'(lambda (quad)
              (when quad (delete-overlay (first quad))))
          idrop-overlays)
    ;;
    ;; Delete possibly inserted missed lines. Even if no missed lines
    ;; were found, try to restore very important `buffer-modified-p'
    ;; state.
    ;;
    (let ((missed-lines (get 'idrop-overlays 'idrop-missed-lines)))
      (when missed-lines
        (let ((inhibit-modification-hooks t)
              (buffer-undo-list t)
              (buffer-read-only nil))
          (save-excursion
            (goto-char (- (point-max) missed-lines))
            (delete-char missed-lines)))
        (put 'idrop-overlays 'idrop-missed-lines nil)
        (when (eq idrop-overlays-saved-modified-state 'idrop-unknown)
          (message "Warning: Buffer modification state may have been incidently changed by idrop!")))
      (cond ((eq idrop-overlays-saved-modified-state 'idrop-modified)
             (set-buffer-modified-p t))
            ((eq idrop-overlays-saved-modified-state 'idrop-not-modified)
             (set-buffer-modified-p nil))
            (t
             nil)))))

(defun idrop-overlays-make-overlay (beg end &optional prop value prop2 value2)
  "Copied from old `dropdown-put-overlay'.

Makes an overlay with two properties and two values. This is where they are actually displayed."
  (let ((ov (make-overlay beg end)))
    (overlay-put ov 'window t)
    (overlay-put ov 'intangible t)
    (when prop
      (overlay-put ov prop value)
      (when prop2 (overlay-put ov prop2 value2)))
    ov))

;;; x) provides

(provide 'idrop-display-methods)